home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr48
/
eev100r1.zip
/
POSTFIX.INC
< prev
next >
Wrap
Text File
|
1993-04-01
|
17KB
|
749 lines
{ ------------------------------------------------------------------------
POSTFIX.INC
------------------------------------------------------------------------
Version 1.00, Revision 1, 02/02/92 -- added TP3 RPN support TP3.0, 5.5, 6.0
Version 1.00, Revision 0, 12/28/91 -- original release TP5.5, 6.0
Written by: David J. Firth
5665-A2 Parkville St.
Columbus, OH 43229
This file provides a complete reverse polish notation (RPN) expression
evaluator. Each part of the RPN expression needs to be separated by a
space. The evaluator supports the following functions:
+ - * / PI ABS ARCTAN COS EXP LN SQR SQRT
The evaluator package includes routines to read and write values
to and from variables. Variables should be 20 or characters or
less in length. During expression evaluation, any unrecognized
string of characters will be assumed to be a variable.
Two procedures are provided for expression evaluation, Calculate and
CalcAndStore. Calculate will evaluate the expression and return the
result to the caller. CalcAndStore will evaluate the expression and
store the result in a variable.
POSTFIX.INC has two major data structures allocated on the heap.
The first is a stack, used for the processing of RPN expressions.
The other is a linked list used to store variables. Before the
application program uses an evaluator function, InitializeEE must
be called to initialize the data structures. Before the
application program is ended, the procedure DestroyList should
be called to deallocate the memory taken by these structures.
API description:
procedure InitializeEE; Init data structures
procedure StoreVariable(VariableID:str20; Put variable in LL
MyValue:real);
procedure ReadVariable(VariableID:str20; Get variable from LL
var MyValue:real;
var MyError:boolean);
procedure DestroyList; Close data structures
procedure Calculate(MyFormula:AnyStr; Evaluate RPN expression
var MyResult:real;
var MyError:boolean);
procedure CalcAndStore(MyFormula:AnyStr; Evaluate/store RPN expr
StoreID:str20;
var MyError:boolean);
------------------------------------------------------------------------
Differences between V1.00R0 and V1.00R1:
All files and functions in Expression Evaluator Tools V1.00R0 exist
in V1.00R1 with the following modifications:
1. V1.00R1 is written to include Turbo Pascal V3.0 by adding POSTFIX.INC,
DFSTR.INC, and TESTP3.PAS.
Changes to the evaluator code in POSTFIX.INC (POSTFIX.PAS is unchanged):
2. Code to test for '+' and '-' has been added to the part of Calculate
that identifies a token as a valid number. TP3.0's Val routine will
evaluate '+' and '-' as 0. TP5.5 sees '+' and '-' as non-numeric.
3. A new procedure, InitializeEE, must be called prior to using the
expression evaluator. InitializeEE performs the function that the
unit initialization code block performs in the TP5.5/TP6.0 version.
4. All references to Dec and Inc are now Succ and Pred.
5. All string types are now declared with sizes.
6. All references to the 255 byte string type are now AnyStr (declared
in DFSTR.INC).
------------------------------------------------------------------------ }
type
Str20 = string[20]; {store variable IDs this way to conserve}
Str128 = string[128];
VariablePtr = ^VariableType; {for dynamic allocation of records }
VariableType = record
ID : Str20; {the id of the variable, with @s }
Value : real; {the current value of the variable }
Next : VariablePtr; {hook to next record in linked list}
end; {VariableType}
StackItemPtr = ^StackItemType; {for dynamic allocation of records }
StackItemType = record
Value : real; {the value to be "operated" upon }
Next : StackItemPtr; {hook to next record in linked list}
end; {StackItemType}
var
HPtr, {head of variable list }
TPtr, {tail of variable list }
SPtr : VariablePtr; {used to search variable list}
STPtr : StackItemPtr; {the top of the stack}
{ ------------------------------------------------------------------------ }
function __ParamCount(MyStr:AnyStr):byte;
{this routine is a work-alike of Turbo's own ParamCount function. this
routine requires my DFStr unit to operate.}
var
Count,
Index : byte;
begin
MyStr := __RemWhiteStr(MyStr,_Leading);
MyStr := __RemWhiteStr(MyStr,_Trailing);
Count := 0;
for Index := 1 to length(MyStr) do
if MyStr[Index]=' ' then
Count := succ(Count);
__ParamCount := Count+1;
end; {__ParamCount}
{ ------------------------------------------------------------------------ }
function __ParamStr(Index:byte;MyStr:AnyStr):AnyStr;
var
TempStr : AnyStr;
I,
J,
P,
Count : byte;
Spaces : array[0..256] of byte;
begin
TempStr := '';
fillchar(Spaces,sizeof(Spaces),0);
Count := __ParamCount(MyStr);
if (Index<=Count) AND (Index>0) then begin
MyStr := __RemWhiteStr(MyStr,_Leading);
MyStr := __RemWhiteStr(MyStr,_Trailing);
MyStr := ' ' + MyStr + ' ';
{load Spaces}
J := 0;
for I := 1 to length(MyStr) do begin
if MyStr[I] = ' ' then begin
Spaces[J] := I;
J := succ(J);
end;
end; {for}
{get the parameter}
TempStr := copy(MyStr,Spaces[Index-1]+1,Spaces[Index]-Spaces[Index-1]-1);
end;
__ParamStr := TempStr;
end; {__ParamStr}
{ ------------------------------------------------------------------------ }
procedure Pop(var MyValue:real;var MyError:boolean);
var
TempPtr : StackItemPtr;
begin
if STPtr=nil then begin
{tried to pop empty stack -- error!}
MyValue := 0;
MyError := true;
end
else begin
{get value}
MyValue := STPtr^.Value;
MyError := false;
{dispose of the record at the top of the stack}
TempPtr := STPtr;
STPtr := STPtr^.Next;
dispose(TempPtr);
end; {if-else}
end; {Pop}
{ ------------------------------------------------------------------------ }
procedure Push(MyValue:real);
var
TempPtr : StackItemPtr;
begin
{create record on heap for value}
new(TempPtr);
TempPtr^.Value := MyValue;
{attach new record as top of stack}
TempPtr^.Next := STPtr;
STPtr := TempPtr;
end; {Push}
{ ------------------------------------------------------------------------ }
procedure DestroyStack(MyPtr:StackItemPtr);
begin
if MyPtr^.Next<>nil then
DestroyStack(MyPtr^.Next);
dispose(MyPtr);
end; {DestroyStack}
{ ------------------------------------------------------------------------ }
procedure GetPointerTo(VariableID:str20;var MPtr:VariablePtr);
var
Done : boolean;
XPtr : VariablePtr;
begin
MPtr := nil;
XPtr := HPtr;
Done := false;
while (not Done) do begin
if XPtr^.ID=VariableID then
MPtr := XPtr;
if XPtr^.Next=nil then
Done := true
else
XPtr := XPtr^.Next;
end; {while}
end; {GetPointerTo}
{ ------------------------------------------------------------------------ }
procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);
var
MPtr : VariablePtr;
begin
MyError := false;
MyValue := 0;
GetPointerTo(VariableID,MPtr);
if MPtr<>nil then begin
MyValue := MPtr^.Value
end
else begin
MyError := true;
end;
end; {ReadVariable}
{ ------------------------------------------------------------------------ }
procedure StoreVariable(VariableID:str20;MyValue:real);
var
WorkingRec : VariableType;
begin
fillchar(WorkingRec,sizeof(WorkingRec),0);
WorkingRec.ID := VariableID;
WorkingRec.Value := MyValue;
If HPtr = nil then begin
{this is the first record added to the list}
New(HPtr); {allocate 1st record in LL }
TPtr := HPtr; {init tail (= head) }
TPtr^ := WorkingRec; {add new record as head }
TPtr^.Next := nil; {set the next link for tail}
end
else begin
GetPointerTo(VariableID,SPtr);
if SPtr <> nil then begin
{the list exists and so does the variable -- modify value}
SPtr^.Value := MyValue;
end
else begin
{the list exists, but the variable doesn't -- add it}
New(SPtr); {allocate new record for LL }
SPtr^ := WorkingRec; {put info in new LL record }
TPtr^.Next := SPtr; {add new record as tail }
SPtr^.Next := nil; {set the new link for tail }
TPtr := SPtr; {point tail to new record }
end; {if-else}
end;
end; {StoreVariable}
{ ------------------------------------------------------------------------- }
Procedure DestroyFieldList(TempPtr:VariablePtr);
{ This procedure recursively destroys a linked list }
Begin
If TempPtr^.Next <> nil then
DestroyFieldList(TempPtr^.Next);
Dispose(TempPtr);
End;
{ ------------------------------------------------------------------------ }
procedure DestroyList;
begin
if HPtr <> Nil then
DestroyFieldList(HPtr);
HPtr := nil;
TPtr := nil;
SPtr := nil;
if STPtr<>nil then
DestroyStack(STPtr);
STPtr := nil;
end; {DestroyList}
{ ------------------------------------------------------------------------ }
procedure DoAdd(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(A+B)
end;
end; {DoAdd}
{ ------------------------------------------------------------------------ }
procedure DoSub(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(B-A)
end;
end; {DoSub}
{ ------------------------------------------------------------------------ }
procedure DoMul(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(A*B)
end;
end; {DoMul}
{ ------------------------------------------------------------------------ }
procedure DoPI(var MyError:boolean);
begin
MyError := false;
Push(3.1415927);
end; {DoPI}
{ ------------------------------------------------------------------------ }
procedure DoABS(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(abs(A))
end;
end; {DoABS}
{ ------------------------------------------------------------------------ }
procedure DoATAN(var MyError:boolean);
{this function works in radians}
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(arctan(A));
end;
end; {DoATAN}
{ ------------------------------------------------------------------------ }
procedure DoCOS(var MyError:boolean);
{this function works in radians}
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(cos(A));
end;
end; {DoCOS}
{ ------------------------------------------------------------------------ }
procedure DoEXP(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(exp(A));
end;
end; {DoEXP}
{ ------------------------------------------------------------------------ }
procedure DoLN(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(ln(A));
end;
end; {DoLN}
{ ------------------------------------------------------------------------ }
procedure DoSQR(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(A*A);
end;
end; {DoSQR}
{ ------------------------------------------------------------------------ }
procedure DoSQRT(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(sqrt(A));
end;
end; {DoSQRT}
{ ------------------------------------------------------------------------ }
procedure DoDiv(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(B/A)
end;
end; {DoDiv}
{ ------------------------------------------------------------------------ }
procedure Calculate(MyFormula:AnyStr;var MyResult:real;var MyError:boolean);
const
{MyFunctions is the lookup table for valid EE operators}
NumFunctions = 12;
MyFunctions : array[1..NumFunctions] of AnyStr = ('+',
'-',
'*',
'/',
'PI',
'ABS',
'ARCTAN',
'COS',
'EXP',
'LN',
'SQR',
'SQRT');
var
Index,
TokenID,
TokenNum,
NumTokens : byte;
CmdTail : ^Str128;
Token : AnyStr;
ValError : integer;
ValReal : real;
VarStr : Str20;
begin
{set up error condition}
MyError := false;
MyResult := 0;
NumTokens := __ParamCount(MyFormula);
if NumTokens>0 then begin
TokenNum := 1;
while (TokenNum<=NumTokens) AND (not MyError) do begin
Token := __ParamStr(TokenNum,MyFormula);
{ In TP5.5, trying to obtain the value of '+' or '-' will generate
an error. In TP3.0, the same function will return a valid number
with a value of zero. This fix will check for '+' and '-' first. }
if (Token='+') OR (Token='-') then begin
{manually force POSTFIX to skip number evaluation}
ValError := 1;
end
else begin
{process the token just like previous version of POSTFIX}
val(Token,ValReal,ValError);
end; {if-else}
if ValError=0 then begin
{token is a valid number - push onto stack}
Push(ValReal);
end
else begin
{token wasn't a number, is it an operator?}
{convert to all caps}
for Index := 1 to length(Token) do
Token[Index] := upcase(Token[Index]);
{search valid functions}
TokenID := 0;
for Index := 1 to NumFunctions do
if MyFunctions[Index]=Token then TokenID := Index;
case TokenID of
0: begin
{search valid variables for Token}
VarStr := copy(Token,1,20);
ReadVariable(VarStr,ValReal,MyError);
if not MyError then
{push variable's value onto stack}
Push(ValReal);
end; {0}
1: DoAdd(MyError);
2: DoSub(MyError);
3: DoMul(MyError);
4: DoDiv(MyError);
5: DoPI(MyError);
6: DoABS(MyError);
7: DoATAN(MyError);
8: DoCOS(MyError);
9: DoEXP(MyError);
10: DoLN(MyError);
11: DoSQR(MyError);
12: DoSQRT(MyError);
end; {case}
end; {if-else}
{point to next token}
TokenNum := succ(TokenNum);
end; {while}
end
else begin
MyError := true;
end;
if not MyError then
{the result of the evaluator is on the stack}
Pop(MyResult,MyError)
else
{problem -- destroy stack}
if STPtr<>nil then DestroyStack(STPtr);
end; {Calculate}
{ ------------------------------------------------------------------------ }
procedure CalcAndStore(MyFormula:AnyStr;StoreID:str20;var MyError:boolean);
var
MyResult : real;
begin
{call calculate to evaluate the expression}
Calculate(MyFormula,MyResult,MyError);
{store the result in a variable}
if not MyError then
StoreVariable(StoreID,MyResult);
end; {Calculate}
{ ------------------------------------------------------------------------ }
procedure InitializeEE;
begin {init block}
{set up linked list to empty state}
HPtr := nil;
TPtr := nil;
SPtr := nil;
{set up the stack}
STPtr := nil;
end; {InitializeEE}
